home *** CD-ROM | disk | FTP | other *** search
/ Workbench Add-On / Workbench Add-On - Volume 1.iso / Dev / Oberon / examples.lha / Examples / Libraries / Intuition / RKMButtonclass.mod < prev    next >
Encoding:
Text File  |  1995-07-02  |  16.9 KB  |  529 lines
  1. (*************************************************************************
  2.  
  3.      $RCSfile: RKMButtonclass.mod $
  4.   Description: Example Boopsi gadget for RKRM:Libraries
  5.  
  6.    Created by: fjc (Frank Copeland)
  7.     $Revision: 1.4 $
  8.       $Author: fjc $
  9.         $Date: 1995/07/02 16:59:58 $
  10.  
  11.   Copyright © 1994-1995, Frank Copeland.
  12.   This example program is part of Oberon-A.
  13.   See Oberon-A.doc for conditions of use and distribution.
  14.  
  15.   Log entries are at the end of the file.
  16.  
  17. *************************************************************************)
  18.  
  19. <* STANDARD- *> <*$ NilChk- StackChk- *>
  20.  
  21. MODULE RKMButtonclass;
  22.  
  23. IMPORT
  24.   SYS := SYSTEM,
  25.   Kernel,
  26.   e   := Exec,
  27.   i   := Intuition,
  28.   u   := Utility,
  29.   gfx := Graphics,
  30.   cf  := ClassFace,
  31.   IE  := InputEvent,
  32.   Errors,
  33.   d   := Dos;
  34.  
  35. CONST
  36.   VersionTag = "$VER: RKMButtonclass 1.4 (4.6.95)\r\n";
  37.   VersionStr = "RKMButtonclass 1.4 (4.6.95)\r\n";
  38.   CopyrightStr = "Copyright © 1994-1995 Frank Copeland";
  39.  
  40. (*
  41. ** Class specifics
  42. *)
  43.  
  44. CONST
  45.  
  46.   rkmButPulse = u.user + 1;
  47.  
  48. TYPE
  49.  
  50.   ButINSTPtr = POINTER [2] TO ButINST;
  51.   ButINST = RECORD [2]
  52.     midX, midY : LONGINT; (* Co-ordinates of middle of gadget *)
  53.   END;
  54.  
  55. CONST
  56.  
  57. (* ButINST has one flag: *)
  58.  
  59.   eraseOnly = 0; (* Tells rendering routine to *)
  60.                  (* only erase the gadget, not *)
  61.                  (* rerender a new one.  This  *)
  62.                  (* lets the gadget erase it-  *)
  63.                  (* self before it rescales.   *)
  64.  
  65. (**************************************************************************)
  66. (* The Main procedure connects an RKMButClass object to a Boopsi integer  *)
  67. (* gadget, which displays the RKMButClass gadget's rkmButPulse value.     *)
  68. (* The code scales and moves the gadget while it is in place.             *)
  69. (**************************************************************************)
  70.  
  71. VAR
  72.  
  73.   pulse2int : ARRAY 2 OF u.TagItem;
  74.  
  75. CONST
  76.  
  77.   intWidth = 40;
  78.   intHeight = 20;
  79.  
  80. VAR
  81.  
  82.   w : i.WindowPtr;
  83.   rkmbutcl : i.IClassPtr;
  84.   integer, but : i.GadgetPtr;
  85.   msg : i.IntuiMessagePtr;
  86.  
  87. (*------------------------------------*)
  88. PROCEDURE^ freeRKMButGadClass ( cl : i.IClassPtr );
  89.  
  90. PROCEDURE* Cleanup (VAR rc : LONGINT);
  91. BEGIN (* Cleanup *)
  92.   IF but # NIL THEN
  93.     SYS.PUTREG (0, i.RemoveGList (w, integer, -1));
  94.     i.DisposeObject (but); but := NIL
  95.   END;
  96.   IF integer # NIL THEN i.DisposeObject (integer); integer := NIL END;
  97.   IF rkmbutcl # NIL THEN freeRKMButGadClass (rkmbutcl); rkmbutcl := NIL END;
  98.   IF w # NIL THEN i.CloseWindow (w); w := NIL END
  99. END Cleanup;
  100.  
  101. (*------------------------------------*)
  102. PROCEDURE Init ();
  103.  
  104. BEGIN (* Init *)
  105.   ASSERT (u.base # NIL, 100);
  106.   pulse2int [0].tag := rkmButPulse; pulse2int [0].data := i.stringaLongVal;
  107.   pulse2int [1].tag := u.end;
  108.   but := NIL; integer := NIL; rkmbutcl := NIL; w := NIL;
  109.   Kernel.SetCleanup (Cleanup)
  110. END Init;
  111.  
  112.  
  113. (*------------------------------------*)
  114. PROCEDURE MainLoop ( attr, value : LONGINT );
  115.  
  116.   VAR done : BOOLEAN; ignore : LONGINT;
  117.  
  118. BEGIN (* MainLoop *)
  119.   done := FALSE;
  120.   ignore := i.SetGadgetAttrs (but^, w, NIL, attr, value, u.done);
  121.   WHILE ~done DO
  122.     e.WaitPort (w.userPort);
  123.     LOOP
  124.       msg := SYS.VAL (i.IntuiMessagePtr, e.GetMsg (w.userPort));
  125.       IF msg = NIL THEN EXIT END;
  126.       IF msg.class = {i.closeWindow} THEN done := TRUE END;
  127.       e.ReplyMsg (msg)
  128.     END;
  129.   END;
  130. END MainLoop;
  131.  
  132. (*------------------------------------*)
  133. PROCEDURE RenderRKMBut
  134.   ( cl : i.IClassPtr; g : i.GadgetPtr; msg : i.RenderPtr )
  135.   : e.APTR;
  136.  
  137.   VAR
  138.     inst : ButINSTPtr;
  139.     rp : gfx.RastPortPtr;
  140.     retval : e.APTR;
  141.     pens : i.DRIPenArrayPtr;
  142.     back, shine, shadow, wd, h, x, y : INTEGER;
  143.  
  144. BEGIN (* RenderRKMBut *)
  145.   inst := cf.InstData (cl, SYS.VAL (i.ObjectPtr, g));
  146.   retval := SYS.VAL (e.APTR, e.LTRUE);
  147.   pens := msg.gInfo.drInfo.pens;
  148.   IF msg.msg.methodID = i.gmRender THEN (* If msg is truly a gmRender message *)
  149.                                     (* (not a Input that looks like a     *)
  150.                                     (* Render), use the rastport within   *)
  151.                                     (* it...                              *)
  152.     rp := msg.rPort
  153.   ELSE                              (* ...Otherwise, get a rastport using *)
  154.                                     (* ObtainGIRPort().                   *)
  155.     rp := i.ObtainGIRPort (msg.gInfo)
  156.   END;
  157.   IF rp # NIL THEN
  158.     IF i.selected IN g.flags THEN      (* If the gadget is selected,  *)
  159.                                        (* reverse the meanings of the *)
  160.                                        (* pens.                       *)
  161.       back := pens [i.fillPen];
  162.       shine := pens [i.shadowPen];
  163.       shadow := pens [i.shinePen]
  164.     ELSE
  165.       back := pens [i.backGroundPen];
  166.       shine := pens [i.shinePen];
  167.       shadow := pens [i.shadowPen]
  168.     END;
  169.     gfx.SetDrMd (rp, gfx.jam1);
  170.  
  171.     gfx.SetAPen (rp, SHORT (back));          (* Erase the old gadget *)
  172.     gfx.RectFill
  173.       ( rp, g.leftEdge,
  174.             g.topEdge,
  175.             g.leftEdge + g.width,
  176.             g.topEdge + g.height );
  177.  
  178.     gfx.SetAPen (rp, SHORT (shadow));            (* Draw shadow edge *)
  179.     gfx.Move (rp, g.leftEdge + 1, g.topEdge + g.height);
  180.     gfx.Draw (rp, g.leftEdge + g.width, g.topEdge + g.height);
  181.     gfx.Draw (rp, g.leftEdge + g.width, g.topEdge + 1);
  182.  
  183.     wd := g.width DIV 4;         (* Draw arrows - Sorry, no frills imagery *)
  184.     h := g.height DIV 2;
  185.     x := g.leftEdge + (wd DIV 2);
  186.     y := g.topEdge + (h DIV 2);
  187.  
  188.     gfx.Move (rp, x, SHORT (inst.midY));
  189.     gfx.Draw (rp, x + wd, y);
  190.     gfx.Draw (rp, x + wd, y + g.height - h);
  191.     gfx.Draw (rp, x, SHORT (inst.midY));
  192.  
  193.     x := g.leftEdge + (wd DIV 2) + g.width DIV 2;
  194.  
  195.     gfx.Move (rp, x + wd, SHORT (inst.midY));
  196.     gfx.Draw (rp, x, y);
  197.     gfx.Draw (rp, x, y + g.height - h);
  198.     gfx.Draw (rp, x + wd, SHORT (inst.midY));
  199.  
  200.     gfx.SetAPen (rp, SHORT (shine));              (* Draw shine edge *)
  201.     gfx.Move (rp, g.leftEdge, g.topEdge + g.height - 1);
  202.     gfx.Draw (rp, g.leftEdge, g.topEdge);
  203.     gfx.Draw (rp, g.leftEdge + g.width - 1, g.topEdge);
  204.  
  205.     IF msg.msg.methodID # i.gmRender THEN (* If we allocated a rastport, give *)
  206.                                       (* it back. *)
  207.       i.ReleaseGIRPort (rp)
  208.     END;
  209.   ELSE
  210.     retval := SYS.VAL (e.APTR, e.LFALSE);
  211.   END;
  212.   RETURN retval
  213. END RenderRKMBut;
  214.  
  215.  
  216. (*------------------------------------*)
  217. PROCEDURE NotifyPulse
  218.   ( cl    : i.IClassPtr;
  219.     o     : i.ObjectPtr;
  220.     flags : SET;
  221.     mid   : LONGINT;
  222.     gpi   : i.InputPtr );
  223.  
  224.   VAR
  225.     tt : ARRAY 3 OF u.TagItem;
  226.     g : i.GadgetPtr;
  227.     ignore : e.APTR;
  228.  
  229. BEGIN (* NotifyPulse *)
  230.   g := SYS.VAL (i.GadgetPtr, o);
  231.  
  232.   tt[0].tag := rkmButPulse;
  233.   tt[0].data := mid - gpi.mouse.x + g.leftEdge;
  234.  
  235.   tt[1].tag := i.gaID;
  236.   tt[1].data := g.gadgetID;
  237.  
  238.   tt[2].tag := u.done;
  239.  
  240.   ignore := cf.DoSuperMethod
  241.     (cl, o, i.omNotify, SYS.ADR (tt), gpi.gInfo, flags)
  242. END NotifyPulse;
  243.  
  244. (*------------------------------------*)
  245. PROCEDURE* dispatchRKMButGad
  246.   ( hook : u.HookPtr; obj : e.APTR; message : e.APTR )
  247.   : e.APTR;
  248.  
  249.   VAR
  250.     cl : i.IClassPtr; o : i.ObjectPtr; msg : i.MsgPtr;
  251.     inst : ButINSTPtr;
  252.     retval, ignore : SYS.LONGWORD;
  253.     object : i.ObjectPtr;
  254.     g : i.GadgetPtr;
  255.     gpi : i.InputPtr;
  256.     ie : IE.InputEventPtr;
  257.     rp : gfx.RastPortPtr;
  258.     x, y, wd, h : INTEGER;
  259.     pens : i.DRIPenArrayPtr;
  260.     opSet : i.OpSetPtr;
  261.  
  262. BEGIN (* dispatchRKMButGad *)
  263.   cl := SYS.VAL (i.IClassPtr, hook);
  264.   o := obj;
  265.   msg := message;
  266.   retval := e.LTRUE;
  267.   CASE msg.methodID OF
  268.     i.omNew : (* First, pass up to superclass *)
  269.       object := cf.DoSuperMethodA (cl, o, msg^);
  270.       IF object # NIL THEN
  271.         g := SYS.VAL (i.GadgetPtr, object);
  272.                 (* Initial local instance data *)
  273.         inst := cf.InstData (cl, object);
  274.         inst.midX := g.leftEdge + (g.width DIV 2);
  275.         inst.midY := g.topEdge + (g.height DIV 2);
  276.         retval := object
  277.       END;
  278.     |
  279.     i.gmHitTest :
  280.           (* Since this is a rectangular gadget this *)
  281.           (* method always returns i.gmrGadgetHit.   *)
  282.       retval := i.gmrGadgetHit;
  283.     |
  284.     i.gmGoActive :
  285.       inst := cf.InstData (cl, o);
  286.           (* Only become active if the gmGoActive *)
  287.           (* was triggered by direct user input.  *)
  288.       gpi := SYS.VAL (i.InputPtr, msg);
  289.       IF gpi.iEvent # NIL THEN
  290.             (* This gadget is now active, change    *)
  291.             (* visual state to selected and render. *)
  292.         g := SYS.VAL (i.GadgetPtr, o);
  293.         INCL (g.flags, i.selected);
  294.         ignore := RenderRKMBut (cl, g, SYS.VAL (i.RenderPtr, msg));
  295.         retval := i.gmrMeActive
  296.       ELSE    (* The gmGoActive was not         *)
  297.               (* triggered by direct user input *)
  298.         retval := i.gmrNoReuse
  299.       END;
  300.     |
  301.     i.gmRender :
  302.       g := SYS.VAL (i.GadgetPtr, o);
  303.       retval := RenderRKMBut (cl, g, SYS.VAL (i.RenderPtr, msg));
  304.     |
  305.     i.gmHandleInput : (* While it is active, this gadget sends its      *)
  306.                       (* superclass an omNotify pulse for every         *)
  307.                       (* classTimer event that goes by (about one every *)
  308.                       (* 10th of a second).  Any object that is         *)
  309.                       (* connected to this gadget will get A LOT of     *)
  310.                       (* omUpdate messages.                             *)
  311.       g := SYS.VAL (i.GadgetPtr, o);
  312.       gpi := SYS.VAL (i.InputPtr, msg);
  313.       ie := SYS.VAL (IE.InputEventPtr, gpi.iEvent);
  314.  
  315.       inst := cf.InstData (cl, o);
  316.  
  317.       retval := i.gmrMeActive;
  318.  
  319.       IF ie.class = IE.rawmouse THEN
  320.         CASE ie.code OF
  321.           i.selectUp :  (* The user let go of the gadget so return       *)
  322.                         (* gmrNoReuse to deactivate and to tell          *)
  323.                         (* Intuition not to reuse this Input Event as we *)
  324.                         (* have already processed it.                    *)
  325.  
  326.                         (* If the user let go of the gadget while the    *)
  327.                         (* mouse was over it, mask gmrVerify into the    *)
  328.                         (* return value so Intuition will send a Release *)
  329.                         (* Verify (gadgetUp).                            *)
  330.             IF
  331.               (gpi.mouse.x < g.leftEdge) OR
  332.               (gpi.mouse.x > g.leftEdge + g.width) OR
  333.               (gpi.mouse.y < g.topEdge) OR
  334.               (gpi.mouse.y > g.topEdge + g.height)
  335.             THEN
  336.               retval := i.gmrNoReuse + i.gmrVerify
  337.             ELSE
  338.               retval := i.gmrNoReuse
  339.             END;
  340.  
  341.                      (* Since the gadget is going inactive, send a final *)
  342.                      (* notification to the icaTarget                    *)
  343.             NotifyPulse (cl, o, {}, inst.midX, gpi)
  344.           |
  345.           i.menuDown :  (* The user hit the menu button. Go inactive and *)
  346.                         (* let Intuition reuse the menu button event so  *)
  347.                         (* Intuition can pop up the menu bar.            *)
  348.             retval := i.gmrReuse;
  349.             NotifyPulse (cl, o, {}, inst.midX, gpi)
  350.           |
  351.         ELSE
  352.           retval := i.gmrMeActive
  353.         END
  354.       ELSIF ie.class = IE.timer THEN
  355.             (* If the gadget gets a timer event, it sends an interim *)
  356.             (* omNotify to its superclass.                           *)
  357.         NotifyPulse (cl, o, {i.opuInterim}, inst.midX, gpi)
  358.       END;
  359.     |
  360.     i.gmGoInactive :      (* Intuition said to go inactive.  Clear the    *)
  361.                           (* gflgSelected bit and render using unselected *)
  362.                           (* imagery.                                     *)
  363.       g := SYS.VAL (i.GadgetPtr, o);
  364.       EXCL (g.flags, i.selected);
  365.       ignore := RenderRKMBut (cl, g, SYS.VAL (i.RenderPtr, msg));
  366.     |
  367.     i.omSet :    (* Although this class doesn't have settable attributes, *)
  368.                  (* this gadget class does have scaleable imagery, so it  *)
  369.                  (* needs to find out when its size and/or position has   *)
  370.                  (* changed so it can erase itself, THEN scale, and       *)
  371.                  (* rerender.                                             *)
  372.       opSet := SYS.VAL (i.OpSetPtr, msg);
  373.       IF
  374.         (u.FindTagItem (i.gaWidth, opSet.attrList) # NIL) OR
  375.         (u.FindTagItem (i.gaHeight, opSet.attrList) # NIL) OR
  376.         (u.FindTagItem (i.gaTop, opSet.attrList) # NIL) OR
  377.         (u.FindTagItem (i.gaLeft, opSet.attrList) # NIL)
  378.       THEN
  379.         g := SYS.VAL (i.GadgetPtr, o);
  380.  
  381.         x := g.leftEdge;
  382.         y := g.topEdge;
  383.         wd := g.width;
  384.         h := g.height;
  385.  
  386.         inst := cf.InstData (cl, o);
  387.  
  388.         retval := cf.DoSuperMethodA (cl, o, msg^);
  389.  
  390.                                     (* Get pointer to RastPort for gadget *)
  391.         rp := i.ObtainGIRPort (opSet.gInfo);
  392.         IF rp # NIL THEN
  393.           pens := opSet.gInfo.drInfo.pens;
  394.           gfx.SetAPen (rp, SHORT (pens [i.backGroundPen]));
  395.           gfx.SetDrMd (rp, gfx.jam1);       (* Erase the old gadget. *)
  396.           gfx.RectFill (rp, x, y, x+wd, y+h);
  397.  
  398.           inst.midX := g.leftEdge + (g.width DIV 2); (* Recalculate where *)
  399.           inst.midY := g.topEdge + (g.height DIV 2); (* the center of the *)
  400.                                                      (* gadget is. *)
  401.  
  402.                                                   (* Rerender the gadget. *)
  403.           ignore :=
  404.             cf.DoMethod (o, i.gmRender, opSet.gInfo, rp, i.gRedrawRedraw);
  405.           i.ReleaseGIRPort (rp)
  406.         END;
  407.       ELSE
  408.         retval := cf.DoSuperMethodA (cl, o, msg^)
  409.       END;
  410.     |
  411.   ELSE (* rkmbutgadclass does not recognize the methodId, let the *)
  412.        (* superclass's dispatcher take a look at it. *)
  413.     retval := cf.DoSuperMethodA (cl, o, msg^);
  414.   END;
  415.   RETURN SYS.VAL (e.APTR, retval)
  416. END dispatchRKMButGad;
  417.  
  418. (*------------------------------------*)
  419. PROCEDURE initRKMButGadClass () : i.IClassPtr;
  420.  
  421.   VAR
  422.     cl : i.IClassPtr;
  423.  
  424. BEGIN (* initRKMButGadClass *)
  425.   cl := i.MakeClass ( "", "gadgetclass", NIL, SIZE (ButINST), {} );
  426.   IF cl # NIL THEN
  427.     (* initialize the IClass Hook *)
  428.     u.InitHook (cl, dispatchRKMButGad);
  429.   END;
  430.   RETURN cl
  431. END initRKMButGadClass;
  432.  
  433.  
  434. (*------------------------------------*)
  435. PROCEDURE freeRKMButGadClass ( cl : i.IClassPtr );
  436.  
  437.   VAR ignore : BOOLEAN;
  438.  
  439. BEGIN (* freeRKMButGadClass *)
  440.   ignore := i.FreeClass (cl)
  441. END freeRKMButGadClass;
  442.  
  443. (*------------------------------------*)
  444. PROCEDURE Main ();
  445.  
  446.   VAR ignore : INTEGER;
  447.  
  448. BEGIN (* Main *)
  449.   IF i.base.libNode.version >= 37 THEN
  450.     IF u.base.libNode.version >= 37 THEN
  451.       IF gfx.base.libNode.version >= 37 THEN
  452.         w := i.OpenWindowTagsA
  453.           ( NIL,
  454.             i.waFlags,  { i.windowDepth, i.windowDrag,
  455.                           i.windowClose, i.windowSizing },
  456.             i.waIDCMP,  {i.closeWindow},
  457.             i.waWidth,  640,
  458.             i.waHeight, 200,
  459.             u.end );
  460.         IF w # NIL THEN
  461.           IF i.WindowLimits (w, 450, 200, 640, 200) THEN END;
  462.           rkmbutcl := initRKMButGadClass();
  463.           IF rkmbutcl # NIL THEN
  464.             integer := i.NewObject
  465.               ( NIL, "strgclass",
  466.                 i.gaID,            1,
  467.                 i.gaTop,           LONG (w.borderTop) + 5,
  468.                 i.gaLeft,          LONG (w.borderLeft) + 5,
  469.                 i.gaWidth,         intWidth,
  470.                 i.gaHeight,        intHeight,
  471.                 i.stringaLongVal,  0,
  472.                 i.stringaMaxChars, 5,
  473.                 u.end );
  474.             IF integer # NIL THEN
  475.               but := i.NewObject
  476.                 ( rkmbutcl, "",
  477.                   i.gaID,            2,
  478.                   i.gaTop,           LONG (w.borderTop) + 5,
  479.                   i.gaLeft,          integer.leftEdge + integer.width + 5,
  480.                   i.gaWidth,         40,
  481.                   i.gaHeight,        intHeight,
  482.                   i.gaPrevious,      integer,
  483.                   i.icaMap,          SYS.ADR (pulse2int),
  484.                   i.icaTarget,       integer,
  485.                   u.end );
  486.               IF but # NIL THEN
  487.                 ignore := i.AddGList (w, integer, -1, -1, NIL);
  488.                 i.RefreshGList (integer, w, NIL, -1);
  489.  
  490.                 i.SetWindowTitles
  491.                   ( w, SYS.ADR ("<-- Click to resize gadget Height"), NIL );
  492.                 MainLoop (u.done, 0);
  493.  
  494.                 i.SetWindowTitles
  495.                   ( w, SYS.ADR ("<-- Click to resize gadget Width"), NIL );
  496.                 MainLoop (i.gaHeight, 100);
  497.  
  498.                 i.SetWindowTitles
  499.                   ( w, SYS.ADR ("<-- Click to resize gadget Y position"), NIL );
  500.                 MainLoop (i.gaWidth, 100);
  501.  
  502.                 i.SetWindowTitles
  503.                   ( w, SYS.ADR ("<-- Click to resize gadget X position"), NIL );
  504.                 MainLoop (i.gaTop, but.topEdge + 20);
  505.  
  506.                 i.SetWindowTitles
  507.                   ( w, SYS.ADR ("<-- Click to quit"), NIL );
  508.                 MainLoop (i.gaLeft, but.leftEdge + 20);
  509.  
  510.                 ignore := i.RemoveGList (w, integer, -1);
  511.                 i.DisposeObject (but); but := NIL
  512.               END;
  513.               i.DisposeObject (integer); integer := NIL
  514.             END;
  515.             freeRKMButGadClass (rkmbutcl); rkmbutcl := NIL
  516.           END;
  517.           i.CloseWindow (w); w := NIL
  518.         END;
  519.       END;
  520.     END;
  521.   END
  522. END Main;
  523.  
  524. BEGIN (* RKMButtonclass *)
  525.   Errors.Init;
  526.   Init ();
  527.   Main ();
  528. END RKMButtonclass.
  529.